home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 071-080 / amok71 / openclose / openclose.mod < prev    next >
Text File  |  1993-11-04  |  27KB  |  990 lines
  1. (**************************************************************************
  2.  
  3.  
  4. :Program.       IMPLEMENTATION MODULE OpenClose
  5.  
  6. :Contents.      intelligente Open-Funktionen und Close-Prozeduren
  7.  
  8. :Usage.         einfach importieren und benutzen...
  9.  
  10.  
  11. :Copyright.     Public Domain.
  12.  
  13. :Author.        Thomas Ansorge
  14.  
  15. :Address.       Dinkelackerring 55, W-6730 Neustadt, Deutschland
  16.  
  17.  
  18. :Language.      Modula-2
  19.  
  20. :Translator.    M2Amiga V4.0 (deutsch)
  21.  
  22.  
  23. :Version.       1.4 vom 17.05.1992
  24.  
  25. :History.       0.9 vom 06.12.1991: erste Tipparbeiten...
  26.  
  27. :History.       1.0 vom 08.12.1991: Es läuft.
  28.  
  29. :History.       1.1 vom 21.12.1991:
  30. :History.          - verbesserte Fehlerbehandlung
  31. :History.          - OFont integriert
  32. :History.          - OpenWindow überprüft ggf. Existenz d. Custom-Screens
  33.  
  34. :History.       1.2 vom 01.01.1992:
  35. :History.          - Verbesserung in CreatePort
  36. :History.          - Verbesserung in CloseWindow
  37.  
  38. :History.       1.3 vom 07.04.1992:
  39. :History.          - neue Variablen: AFPuffer, DebugMode
  40.  
  41. :History.       1.4 vom 17.05.1992:
  42. :History.          - neue Funktion OpenScreenTagList
  43. :History.          - neue Variable kick20
  44.  
  45.  
  46. :Remark.        Die Dokumentation ist im Definitions-Modul zu finden.
  47.  
  48.  
  49. **************************************************************************)
  50.  
  51.  
  52. IMPLEMENTATION MODULE OpenClose;
  53.  
  54. (*$ NameChk := FALSE  LargeVars := FALSE  LongAlign := FALSE *)
  55.  
  56. FROM Arts IMPORT Assert, BreakPoint, kickVersion, Requester;
  57.  
  58. IMPORT DD: DosD;
  59.  
  60. IMPORT DL: DosL;
  61.  
  62. FROM DiskFontD IMPORT AvailFont, AvailFontHeader, AvailFontHeaderPtr,
  63.                       AvailFontTypes, AvailFontsSet;
  64.  
  65. FROM DiskFontL IMPORT AvailFonts, OpenDiskFont;
  66.  
  67. IMPORT ED: ExecD;
  68.  
  69. IMPORT ES: ExecSupport;
  70.  
  71. FROM ExecL IMPORT FindPort, Forbid, Permit;
  72.  
  73. IMPORT GD: GraphicsD;
  74.  
  75. IMPORT GL: GraphicsL;
  76.  
  77. FROM Heap IMPORT Allocate, Deallocate, Largest;
  78.  
  79. IMPORT ID: IntuitionD;
  80.  
  81. IMPORT IL: IntuitionL;
  82.  
  83. FROM String IMPORT Compare;
  84.  
  85. FROM SYSTEM IMPORT ADDRESS, ADR, BPTR, CAST;
  86.  
  87. IMPORT UD: UtilityD;
  88.  
  89. (* --------------------------------------------------------------------- *)
  90.  
  91. TYPE ResourcenTyp = (file, font, port, screen, window);
  92.  
  93.      ResourcenListePtr = POINTER TO ResourcenListe;
  94.      ResourcenListe    = RECORD
  95.                             Knoten : ED.MinNode;
  96.                             Adresse: ADDRESS;
  97.                             Typ    : ResourcenTyp;
  98.                          END (* RECORD ResourcenListe *);
  99.  
  100. VAR ResListePtr: ResourcenListePtr; (* im folgenden global *)
  101.     HilfePtr   : ResourcenListePtr; (* wird nur im CLOSE-Teil gebraucht *)
  102.  
  103.     AFPufferPtrMem,
  104.     AFPufferPtrDisk : AvailFontHeaderPtr; (* global für OpenFont *)
  105.  
  106. (* --------------------------------------------------------------------- *)
  107.  
  108. (* Die Funktionen und Prozeduren dieses Moduls sind der besseren         *)
  109. (* Lesbarkeit desselben wegen alphabetisch geordnet. Da einige           *)
  110. (* Funktionen/Prozeduren andere aufrufen, seien diese, falls nötig, hier *)
  111. (* dem Compiler bekanntgemacht:                                          *)
  112.  
  113. PROCEDURE ExistiertEintrag (Eintrag: ADDRESS): BOOLEAN; FORWARD;
  114.  
  115. PROCEDURE HandleError (Text: ARRAY OF CHAR); FORWARD;
  116.  
  117. PROCEDURE NeuesListenElement (Typ    : ResourcenTyp;
  118.                               Adresse: ADDRESS): BOOLEAN; FORWARD;
  119.  
  120. (* --------------------------------------------------------------------- *)
  121.  
  122. PROCEDURE Close (VAR File: DD.FileHandlePtr);
  123.  
  124.    (* DosSupport kümmert sich zwar bereits um alles, ich möchte aber auf *)
  125.    (* Nummer sicher gehen.                                               *)
  126.  
  127.    CONST ErrorFile = "Listeneintrag für File nicht gefunden!";
  128.  
  129.    (* ------------------------------------------------------------------ *)
  130.  
  131.    BEGIN (* Prozedur Close *);
  132.  
  133.    IF ExistiertEintrag (File) THEN
  134.       LoescheListenEintrag (File);
  135.  
  136.       DL.Close (File);
  137.  
  138.       IF NOT DebugMode THEN
  139.          File := NIL;
  140.       END (* IF NOT DebugMode *);
  141.  
  142.    ELSE (* IF ExistiertEintrag *)
  143.       IF DebugMode THEN
  144.          BreakPoint (ADR (ErrorFile));
  145.       END (* IF DebugMode *);
  146.    END (* IF ExistiertEintrag *);
  147. END Close (* Prozedur *);
  148.  
  149. (* --------------------------------------------------------------------- *)
  150.  
  151. PROCEDURE CloseFont (VAR Font: GD.TextFontPtr);
  152.  
  153.    CONST ErrorFont = "Listeneintrag für Font nicht gefunden!";
  154.  
  155.    (* ------------------------------------------------------------------ *)
  156.  
  157.    BEGIN (* Prozedur CloseFont *)
  158.  
  159.    IF ExistiertEintrag (Font) THEN
  160.       LoescheListenEintrag (Font);
  161.  
  162.       Forbid ();
  163.       GL.CloseFont (Font);
  164.       Permit ();
  165.  
  166.       IF NOT DebugMode THEN
  167.          Font := NIL;
  168.       END (* IF NOT DebugMode *);
  169.  
  170.    ELSE (* IF ExistiertEintrag *)
  171.       IF DebugMode THEN
  172.          BreakPoint (ADR (ErrorFont));
  173.       END (* IF DebugMode *);
  174.    END (* IF ExistiertEintrag *);
  175. END CloseFont (* Prozedur *);
  176.  
  177. (* --------------------------------------------------------------------- *)
  178.  
  179. PROCEDURE CloseScreen (VAR Screen: ID.ScreenPtr);
  180.  
  181.    CONST ErrorScreen1 = "Listeneintrag für Screen nicht gefunden!";
  182.          ErrorScreen2 = "Systemeintrag für Screen nicht gefunden!";
  183.  
  184.    VAR IBasePtr : ID.IntuitionBasePtr;
  185.        ScreenPtr: ID.ScreenPtr;
  186.  
  187.    (* ------------------------------------------------------------------ *)
  188.  
  189.    BEGIN (* Prozedur CloseScreen *)
  190.  
  191.    IF ExistiertEintrag (Screen) THEN
  192.       Forbid ();
  193.  
  194.       IBasePtr := IL.OpenIntuition ();
  195.       ScreenPtr := IBasePtr^.firstScreen;
  196.  
  197.       WHILE (ScreenPtr # NIL) AND (ScreenPtr # Screen) DO
  198.          ScreenPtr := ScreenPtr^.nextScreen;
  199.       END (* WHILE *);
  200.  
  201.       IF ScreenPtr = NIL THEN
  202.          (* der Screen existiert gar nicht mehr! *)
  203.  
  204.          IF DebugMode THEN
  205.             BreakPoint (ADR (ErrorScreen2));
  206.          END (* IF DebugMode *);
  207.  
  208.          LoescheListenEintrag (Screen);
  209.  
  210.       ELSE (* der Screen existiert in beiden Listen *)
  211.          IF Screen^.firstWindow = NIL THEN
  212.             LoescheListenEintrag (Screen);
  213.  
  214.             IL.CloseScreen (Screen);
  215.  
  216.             IF NOT DebugMode THEN
  217.                Screen := NIL;
  218.             END (* IF NOT DebugMode *);
  219.          END (* IF Screen^.firstWindow *);
  220.       END (* IF ScreenPtr *);
  221.  
  222.       Permit ();
  223.  
  224.    ELSE (* IF ExistiertEintrag *)
  225.       IF DebugMode THEN
  226.          BreakPoint (ADR (ErrorScreen1));
  227.       END (* IF DebugMode *);
  228.    END (* IF ExistiertEintrag *);
  229. END CloseScreen (* Prozedur *);
  230.  
  231. (* --------------------------------------------------------------------- *)
  232.  
  233. PROCEDURE CloseWindow (VAR Window: ID.WindowPtr);
  234.  
  235.    CONST ErrorWindow1 = "Listeneintrag für Window nicht gefunden!";
  236.          ErrorWindow2 = "Systemeintrag für Window nicht gefunden!";
  237.  
  238.    VAR IBasePtr: ID.IntuitionBasePtr;
  239.        Screen  : ID.ScreenPtr;
  240.        Fenster : ID.WindowPtr;
  241.  
  242.    (* ------------------------------------------------------------------ *)
  243.  
  244.    BEGIN (* Prozedur CloseWindow *)
  245.  
  246.    IBasePtr := NIL;
  247.    Screen := NIL;
  248.    Fenster := NIL;
  249.  
  250.    IF ExistiertEintrag (Window) THEN
  251.       (* ist das Fenster tatsächlich offen? *)
  252.  
  253.       Forbid ();
  254.       IBasePtr := IL.OpenIntuition ();
  255.  
  256.       IF IBasePtr # NIL THEN
  257.          Screen := IBasePtr^.firstScreen;
  258.  
  259.          REPEAT
  260.             Fenster := Screen^.firstWindow;
  261.  
  262.             WHILE (Fenster # Window) AND (Fenster # NIL) DO
  263.                Fenster := Fenster^.nextWindow;
  264.             END (* WHILE *);
  265.  
  266.             IF Fenster # Window THEN
  267.                Screen := Screen^.nextScreen;
  268.             END (* IF Fenster *);
  269.          UNTIL (Fenster = Window) OR (Screen = NIL);
  270.       END (* IF IBasePtr *);
  271.  
  272.       (* Der Eintrag existiert, muß also gelöscht werden. *)
  273.  
  274.       LoescheListenEintrag (Window);
  275.  
  276.       (* Wenn auch das Fenster existiert, muß es geschlossen werden. *)
  277.  
  278.       IF Fenster = Window THEN
  279.          IL.CloseWindow (Window);
  280.  
  281.          IF NOT DebugMode THEN
  282.             Window := NIL;
  283.          END (* IF NOT DebugMode *);
  284.  
  285.       ELSE (* IF Fenster = Window *)
  286.          IF DebugMode THEN
  287.             Permit ();
  288.             BreakPoint (ADR (ErrorWindow2));
  289.             Forbid (); (* für das folgende Permit *)
  290.          END (* IF DebugMode *);
  291.       END (* IF Fenster *);
  292.  
  293.       Permit ();
  294.  
  295.    ELSE (* IF ExistiertEintrag *);
  296.       IF DebugMode THEN
  297.          BreakPoint (ADR (ErrorWindow1));
  298.       END (* IF DebugMode *);
  299.    END (* IF ExistiertEintrag *);
  300. END CloseWindow (* Prozedur *);
  301.  
  302. (* --------------------------------------------------------------------- *)
  303.  
  304. PROCEDURE CreatePort (portName: ADDRESS;
  305.                       priority: SHORTINT): ED.MsgPortPtr;
  306.  
  307.    CONST KeinPort = "Error in OpenClose.CreatePort!";
  308.  
  309.    VAR PortPtr: ED.MsgPortPtr;
  310.  
  311.    (* ------------------------------------------------------------------ *)
  312.  
  313.    BEGIN (* Funktion CreatePort *)
  314.  
  315.    PortPtr := NIL;
  316.  
  317.    IF portName # NIL THEN
  318.       Forbid ();
  319.       PortPtr := FindPort (portName);
  320.  
  321.       IF PortPtr = NIL THEN
  322.          PortPtr := ES.CreatePort (portName, priority);
  323.  
  324.       ELSE (* Fehler: der Port ist schon da! *)
  325.          PortPtr := NIL;
  326.       END (* IF PortPtr *);
  327.  
  328.       Permit ();
  329.    END (* IF PortName *);
  330.  
  331.    IF PortPtr = NIL THEN
  332.       HandleError (KeinPort);
  333.    ELSE (* Port offen *)
  334.  
  335.       (*$ NilChk := FALSE *)
  336.  
  337.       IF NOT NeuesListenElement (port, PortPtr) THEN
  338.          Forbid ();
  339.          ES.DeletePort (PortPtr);
  340.          PortPtr := NIL;
  341.          Permit ();
  342.  
  343.          HandleError (KeinPort);
  344.       END (* IF NOT *);
  345.  
  346.       (*$ POP NilChk *)
  347.  
  348.    END (* IF Port *);
  349.  
  350.    RETURN PortPtr;
  351. END CreatePort (* Funktion *);
  352.  
  353. (* --------------------------------------------------------------------- *)
  354.  
  355. PROCEDURE DeallocateAFDiskPuffer;
  356.  
  357.    (* löscht AFPufferPtrDisk falls vorhanden *)
  358.  
  359.    BEGIN (* Prozedur DeallocateAFDiskPuffer *)
  360.  
  361.    IF AFPufferPtrDisk # NIL THEN
  362.       Deallocate (AFPufferPtrDisk);
  363.    END (* IF AFPufferPrtDisk *);
  364. END DeallocateAFDiskPuffer (* Prozedur *);
  365.  
  366. (* --------------------------------------------------------------------- *)
  367.  
  368. PROCEDURE DeallocateAFMemPuffer;
  369.  
  370.    (* löscht AFPufferPtrMem falls vorhanden *)
  371.  
  372.    BEGIN (* Prozedur DeallocateAFPuffer *)
  373.  
  374.    IF AFPufferPtrMem # NIL THEN
  375.       Deallocate (AFPufferPtrMem);
  376.    END (* IF AFPufferPrtMem *);
  377. END DeallocateAFMemPuffer (* Prozedur *);
  378.  
  379. (* --------------------------------------------------------------------- *)
  380.  
  381. PROCEDURE DeletePort (VAR Port: ED.MsgPortPtr);
  382.  
  383.    CONST ErrorPort = "Listeneintrag für Port nicht gefunden!";
  384.  
  385.    (* ------------------------------------------------------------------ *)
  386.  
  387.    BEGIN (* Prozedur DeletePort *)
  388.  
  389.    IF ExistiertEintrag (Port) THEN
  390.       LoescheListenEintrag (Port);
  391.  
  392.       Forbid ();
  393.       ES.DeletePort (Port);
  394.       Permit ();
  395.  
  396.       IF NOT DebugMode THEN
  397.          Port := NIL;
  398.       END (* IF NOT DebugMode *);
  399.  
  400.    ELSE (* IF ExistiertEintrag *)
  401.       IF DebugMode THEN
  402.          BreakPoint (ADR (ErrorPort));
  403.       END (* IF DebugMode *);
  404.    END (* IF ExistiertEintrag *);
  405. END DeletePort (* Prozedur *);
  406.  
  407. (* --------------------------------------------------------------------- *)
  408.  
  409. PROCEDURE ExistiertEintrag (Eintrag: ADDRESS): BOOLEAN;
  410.  
  411.    VAR ListenEintrag: ResourcenListePtr;
  412.  
  413.    (* ------------------------------------------------------------------ *)
  414.  
  415.    BEGIN (* Funktion ExistiertEintrag *)
  416.  
  417.    ListenEintrag := ResListePtr;
  418.    
  419.    LOOP
  420.       IF ListenEintrag # NIL THEN
  421.          IF Eintrag = ListenEintrag^.Adresse THEN
  422.             EXIT; (* LOOP *)
  423.          
  424.          ELSE (* IF Eintrag *)
  425.             ListenEintrag := CAST (ResourcenListePtr,
  426.                ListenEintrag^.Knoten.succ);
  427.          END (* IF Eintrag *);
  428.       
  429.       ELSE (* IF ListenEintrag *)
  430.          EXIT; (* LOOP *)
  431.       END (* IF ListenEintrag *);
  432.    END (* LOOP *);
  433.  
  434.    RETURN (ListenEintrag # NIL);
  435. END ExistiertEintrag (* Funktion *);
  436.  
  437. (* --------------------------------------------------------------------- *)
  438.  
  439. PROCEDURE HandleError (Text: ARRAY OF CHAR);
  440.  
  441.    (* wird im Fehlerfall aufgerufen und veranlaßt eine Fehlerbehandlung  *)
  442.    (* gemäß der Variablen ErrorHandling                                  *)
  443.  
  444.    BEGIN (* Prozedur ErrorHandling *)
  445.  
  446.    CASE ErrorHandling OF
  447.       |ErrorAssert    : Assert (FALSE, ADR (Text));
  448.  
  449.       |ErrorBreakPoint: BreakPoint (ADR (Text));
  450.  
  451.    ELSE (* ErrorNothing - nichts tun *)
  452.    END (* CASE ErrorHandling OF *);
  453. END HandleError (* Prozedur *);
  454.  
  455. (* --------------------------------------------------------------------- *)
  456.  
  457. PROCEDURE LoescheListenEintrag (Eintrag: ADDRESS);
  458.  
  459.    VAR ListenEintrag: ResourcenListePtr;
  460.  
  461.    (* ------------------------------------------------------------------ *)
  462.  
  463.    BEGIN (* Prozedur LoescheListenEintrag *)
  464.  
  465.    ListenEintrag := ResListePtr;
  466.    
  467.    LOOP
  468.       IF ListenEintrag # NIL THEN
  469.          IF Eintrag # ListenEintrag^.Adresse THEN
  470.             ListenEintrag := CAST (ResourcenListePtr,
  471.                ListenEintrag^.Knoten.succ);
  472.          
  473.          ELSE (* IF Eintrag *)
  474.             EXIT (* LOOP *);
  475.          END (* IF Eintrag *);
  476.       
  477.       ELSE (* IF ListenEintrag *)
  478.          EXIT (* LOOP *);
  479.       END (* IF ListenEintrag *);
  480.    END (* LOOP *);
  481.  
  482.    IF ListenEintrag # NIL THEN (* sollte so sein *)
  483.       IF (ListenEintrag^.Knoten.succ # NIL) OR
  484.          (ListenEintrag^.Knoten.pred # NIL) THEN
  485.          (* nicht der einzige Eintrag *)
  486.  
  487.          IF ListenEintrag^.Knoten.succ # NIL THEN
  488.             ListenEintrag^.Knoten.succ^.pred := ListenEintrag^.Knoten.pred;
  489.          END (* IF *);
  490.  
  491.          IF ListenEintrag^.Knoten.pred # NIL THEN
  492.             ListenEintrag^.Knoten.pred^.succ := ListenEintrag^.Knoten.succ;
  493.  
  494.          ELSE (* kein Vorgänger - ResListePtr ändern! *)
  495.             ResListePtr := CAST (ResourcenListePtr,
  496.                            ListenEintrag^.Knoten.succ);
  497.          END (* IF *);
  498.  
  499.       ELSE (* letzter Eintrag! *)
  500.          ResListePtr := NIL;
  501.       END (* IF (ListenEintrag *);
  502.  
  503.       Deallocate (ListenEintrag);
  504.    END (* IF ListenEintrag *);
  505. END LoescheListenEintrag (* Prozedur *);
  506.  
  507. (* --------------------------------------------------------------------- *)
  508.  
  509. PROCEDURE LoescheResourceEintrag (VAR Eintrag: ResourcenListePtr);
  510.  
  511.    CONST ErrorText1 = "OpenClose.CloseScreen:";
  512.          ErrorText2 = "Bitte schließen Sie alle Fenster!";
  513.          ErrorOk    = "Ok";
  514.  
  515.          ErrorFile   = "Sie haben ein File vergessen!";
  516.          ErrorFont   = "Sie haben einen Font vergessen!";
  517.          ErrorPort   = "Sie haben einen Port vergessen!";
  518.          ErrorScreen = "Sie haben einen Screen vergessen!";
  519.          ErrorWindow = "Sie haben ein Window vergessen!";
  520.  
  521.    VAR Dummy   : BOOLEAN;
  522.        FilePtr : DD.FileHandlePtr;
  523.        Screen  : ID.ScreenPtr;
  524.        Window1,
  525.        Window2 : ID.WindowPtr;
  526.  
  527.    (* ------------------------------------------------------------------ *)
  528.  
  529.    BEGIN (* Prozedur LoescheResourceEintrag *)
  530.  
  531.    CASE Eintrag^.Typ OF
  532.       |file  : IF DebugMode THEN
  533.                   BreakPoint (ADR (ErrorFile));
  534.                END (* IF DebugMode *);
  535.                
  536.                FilePtr := BPTR (Eintrag^.Adresse);
  537.                
  538.                Close (FilePtr); (* BPOINTER...GRRRR.... *)
  539.  
  540.       |font  : IF DebugMode THEN
  541.                   BreakPoint (ADR (ErrorFont));
  542.                END (* IF DebugMode *);
  543.  
  544.                CloseFont (CAST (GD.TextFontPtr, Eintrag^.Adresse));
  545.  
  546.       |port  : IF DebugMode THEN
  547.                   BreakPoint (ADR (ErrorPort));
  548.                END (* IF DebugMode *);
  549.  
  550.                DeletePort (CAST (ED.MsgPortPtr, Eintrag^.Adresse));
  551.  
  552.       |screen: Screen := CAST (ID.ScreenPtr, Eintrag^.Adresse);
  553.  
  554.                IF DebugMode THEN
  555.                   BreakPoint (ADR (ErrorScreen));
  556.                END (* IF DebugMode *);
  557.  
  558.                IF Screen^.firstWindow # NIL THEN
  559.                   Window1 := Screen^.firstWindow;
  560.  
  561.                   WHILE Window1 # NIL DO
  562.                      Window2 := Window1;
  563.                      Window1 := Window1^.nextWindow;
  564.  
  565.                      CloseWindow (Window2);
  566.                   END (* WHILE Window1 *);
  567.                END (* IF Screen^. *);
  568.  
  569.                WHILE Screen^.firstWindow # NIL DO
  570.                   Dummy := Requester (ADR (ErrorText1), ADR (ErrorText2),
  571.                               ADR (ErrorOk), ADR (ErrorOk));
  572.                END (* WHILE Screen^ *);
  573.  
  574.                CloseScreen (CAST (ID.ScreenPtr, Eintrag^.Adresse));
  575.  
  576.       |window: IF DebugMode THEN
  577.                   BreakPoint (ADR (ErrorWindow));
  578.                END (* IF DebugMode *);
  579.  
  580.                CloseWindow (CAST (ID.WindowPtr, Eintrag^.Adresse));
  581.    END (* CASE Eintrag^.Typ *);
  582. END LoescheResourceEintrag (* Prozedur *);
  583.  
  584. (* --------------------------------------------------------------------- *)
  585.  
  586. PROCEDURE NeuesListenElement (Typ    : ResourcenTyp;
  587.                               Adresse: ADDRESS      ): BOOLEAN;
  588.  
  589.    (* erstellt einen neuen Listeneintrag. Tritt dabei ein Fehler auf, so *)
  590.    (* gibt es FALSE zurück, andernfalls TRUE. Die aufrufende Funktion    *)
  591.    (* hat das zu überprüfen und die Resource ggf. selber wieder zu       *)
  592.    (* schließen!                                                         *)
  593.  
  594.    VAR Eintrag: ResourcenListePtr;
  595.  
  596.    (* ------------------------------------------------------------------ *)
  597.  
  598.    BEGIN (* Prozedur NeuesListenElement *)
  599.  
  600.    Eintrag := NIL;
  601.  
  602.    IF Adresse # NIL THEN
  603.  
  604.       (*$ NilChk := FALSE *)
  605.  
  606.       Allocate (Eintrag, SIZE (Eintrag^));
  607.  
  608.       (*$ POP NilChk *)
  609.  
  610.       IF Eintrag # NIL THEN
  611.          WITH Eintrag^.Knoten DO
  612.             succ := CAST (ED.MinNodePtr, ResListePtr);
  613.             pred := NIL;
  614.          END (* WITH Eintrag^.Knoten *);
  615.  
  616.          Eintrag^.Typ := Typ;
  617.          Eintrag^.Adresse := Adresse;
  618.  
  619.          ResListePtr := Eintrag;
  620.  
  621.          IF ResListePtr^.Knoten.succ # NIL THEN
  622.             ResListePtr^.Knoten.succ^.pred := CAST (ED.MinNodePtr,
  623.                ResListePtr);
  624.          END (* IF ResListePtr^ *);
  625.  
  626.       ELSE (* kein Speicher für Eintrag! *)
  627.          RETURN FALSE;
  628.       END (* IF Eintrag # NIL *);
  629.  
  630.    ELSE (* Resource nicht geöffnet *)
  631.       RETURN FALSE;
  632.    END (* IF Adresse # NIL *);
  633.  
  634.    RETURN TRUE;
  635. END NeuesListenElement (* Prozedur *);
  636.  
  637. (* --------------------------------------------------------------------- *)
  638.  
  639. PROCEDURE Open (name      : ADDRESS;
  640.                 accessMode: LONGINT): DD.FileHandlePtr;
  641.  
  642.    CONST KeinFile = "Error in OpenClose.Open!";
  643.  
  644.    VAR FilePtr: DD.FileHandlePtr; (* Achtung! BPOINTER! *)
  645.  
  646.    (* ------------------------------------------------------------------ *)
  647.  
  648.    BEGIN (* Funktion Open *)
  649.  
  650.    FilePtr := NIL;
  651.  
  652.    FilePtr := DL.Open (name, accessMode);
  653.  
  654.    IF FilePtr # NIL THEN
  655.  
  656.       (*$ NilChk := FALSE *)
  657.  
  658.       IF NOT NeuesListenElement (file, FilePtr) THEN
  659.          DL.Close (FilePtr);
  660.          FilePtr := NIL;
  661.  
  662.          HandleError (KeinFile);
  663.       END (* IF NOT *);
  664.  
  665.       (*$ POP NilChk *)
  666.  
  667.    ELSE (* kein File geöffnet *)
  668.       HandleError (KeinFile);
  669.    END (* IF FilePtr *);
  670.  
  671.    RETURN FilePtr;
  672. END Open (* Funktion *);
  673.  
  674. (* --------------------------------------------------------------------- *)
  675.  
  676. PROCEDURE OpenFont (textAttr: GD.TextAttrPtr): GD.TextFontPtr;
  677.  
  678.    CONST KeinFont = "Error in OpenClose.OpenFont!";
  679.  
  680.    TYPE String    = ARRAY [0..80] OF CHAR;
  681.         StringPtr = POINTER TO String;
  682.  
  683.    VAR AFont   : POINTER TO AvailFont;
  684.        FontPtr : GD.TextFontPtr; (* der Font *)
  685.        i       : CARDINAL;
  686.        PToStr1,
  687.        PToStr2 : POINTER TO ARRAY [0..30] OF CHAR; (* Fontnamen *)
  688.        Ok      : LONGINT;
  689.  
  690.    (* globale Variablen: AFPuffer, AFPufferPtrMem, AFPufferPtrDisk *)
  691.  
  692.    (* ------------------------------------------------------------------ *)
  693.  
  694.    BEGIN (* Funktion OpenFont *)
  695.  
  696.    FontPtr := NIL;
  697.  
  698.    IF AFPufferPtrMem = NIL THEN
  699.       REPEAT
  700.          IF Largest (FALSE) >= AFPuffer THEN
  701.             Allocate (AFPufferPtrMem, AFPuffer);
  702.          ELSE (* IF Largest *)
  703.             HandleError (KeinFont);
  704.          END (* IF Largest *);
  705.  
  706.          Ok := AvailFonts (AFPufferPtrMem, AFPuffer, AvailFontsSet {memory});
  707.  
  708.          IF Ok # 0 THEN
  709.             Deallocate (AFPufferPtrMem);
  710.  
  711.             AFPuffer := AFPuffer + Ok;
  712.          END (* IF Ok *);
  713.       UNTIL Ok = 0;
  714.    END (* IF AFPufferPtrMem *);
  715.  
  716.    AFont := ADR (AFPufferPtrMem^);
  717.    INC (AFont, SIZE (AFPufferPtrMem^.numEntries));
  718.  
  719.    i := 0;
  720.    PToStr1 := AFont^.attr.name;
  721.    PToStr2 := textAttr^.name;
  722.  
  723.    WHILE (i < AFPufferPtrMem^.numEntries)
  724.          AND NOT ((Compare (PToStr1^, PToStr2^) = 0)
  725.                   AND (AFont^.attr.ySize = textAttr^.ySize)) DO
  726.       INC (i);
  727.  
  728.       IF i < AFPufferPtrMem^.numEntries THEN
  729.          INC (AFont, SIZE (AFont^));
  730.          PToStr1 := AFont^.attr.name;
  731.       END (* IF i *);
  732.    END (* WHILE (i *);
  733.  
  734.    IF i = AFPufferPtrMem^.numEntries THEN
  735.       (* Font nicht im Speicher *)
  736.       IF AFPufferPtrDisk = NIL THEN
  737.          REPEAT
  738.             IF Largest (FALSE) >= AFPuffer THEN
  739.                Allocate (AFPufferPtrDisk, AFPuffer);
  740.             ELSE (* IF Largest *)
  741.                HandleError (KeinFont);
  742.             END (* IF Largest *);
  743.  
  744.             Ok := AvailFonts (AFPufferPtrDisk, AFPuffer, AvailFontsSet {disk});
  745.  
  746.             IF Ok # 0 THEN
  747.                Deallocate (AFPufferPtrDisk);
  748.  
  749.                AFPuffer := AFPuffer + Ok;
  750.             END (* IF Ok *);
  751.          UNTIL Ok = 0;
  752.       END (* IF AFPufferPtrDisk *);
  753.  
  754.       AFont := ADR (AFPufferPtrDisk^);
  755.       INC (AFont, SIZE (AFPufferPtrDisk^.numEntries));
  756.  
  757.       i := 0;
  758.       PToStr1 := AFont^.attr.name;
  759.  
  760.       WHILE (i < AFPufferPtrDisk^.numEntries)
  761.             AND NOT ((Compare (PToStr1^, PToStr2^) = 0)
  762.                      AND (AFont^.attr.ySize = textAttr^.ySize)) DO
  763.          INC (i);
  764.  
  765.          IF i < AFPufferPtrDisk^.numEntries THEN
  766.             INC (AFont, SIZE (AFont^));
  767.             PToStr1 := AFont^.attr.name;
  768.          END (* IF i *);
  769.       END (* WHILE (i *);
  770.  
  771.       IF i >= AFPufferPtrDisk^.numEntries THEN
  772.          HandleError (KeinFont);
  773.  
  774.       ELSE (* IF i >= *)
  775.          IF NOT RememberAFPuffer THEN
  776.             DeallocateAFDiskPuffer;
  777.          END (* IF NOT *);
  778.  
  779.          FontPtr := OpenDiskFont (textAttr);
  780.  
  781.          DeallocateAFMemPuffer;
  782.       END (* IF i *);
  783.    ELSE (* doch ROM-Font *)
  784.       IF NOT RememberAFPuffer THEN
  785.          DeallocateAFMemPuffer;
  786.       END (* IF NOT *);
  787.  
  788.       FontPtr := GL.OpenFont (textAttr);
  789.    END (* IF i = *);
  790.  
  791.    IF FontPtr = NIL THEN
  792.       HandleError (KeinFont);
  793.  
  794.    ELSE (* Font offen *)
  795.  
  796.       (*$ NilChk := FALSE *)
  797.  
  798.       IF NOT NeuesListenElement (font, FontPtr) THEN
  799.          Forbid ();
  800.          GL.CloseFont (FontPtr);
  801.          FontPtr := NIL;
  802.          Permit ();
  803.  
  804.          HandleError (KeinFont);
  805.       END (* IF NOT *);
  806.  
  807.       (*$ POP NilChk *)
  808.  
  809.    END (* IF FontPtr *);
  810.  
  811.    RETURN FontPtr;
  812. END OpenFont (* Funktion *);
  813.  
  814. (* --------------------------------------------------------------------- *)
  815.  
  816. PROCEDURE OpenScreen (VAR newScreen: ID.NewScreen): ID.ScreenPtr;
  817.  
  818.    CONST KeinScreen = "Error in OpenClose.OpenScreen!";
  819.  
  820.    VAR ScreenPtr: ID.ScreenPtr;
  821.  
  822.    (* ------------------------------------------------------------------ *)
  823.  
  824.    BEGIN (* Funktion OpenScreen *)
  825.  
  826.    ScreenPtr := NIL;
  827.  
  828.    Forbid ();
  829.    ScreenPtr := IL.OpenScreen (newScreen);
  830.    Permit ();
  831.  
  832.    IF ScreenPtr # NIL THEN
  833.  
  834.       (*$ NilChk := FALSE *)
  835.  
  836.       IF NOT NeuesListenElement (screen, ScreenPtr) THEN
  837.          Forbid ();
  838.          IL.CloseScreen (ScreenPtr);
  839.          ScreenPtr := NIL;
  840.          Permit ();
  841.  
  842.          HandleError (KeinScreen);
  843.       END (* IF NOT *);
  844.  
  845.       (*$ POP NilChk *)
  846.  
  847.    ELSE (* kein Screen geöffnet *)
  848.       HandleError (KeinScreen);
  849.    END (* IF ScreenPtr *);
  850.  
  851.    RETURN ScreenPtr;
  852. END OpenScreen (* Funktion *);
  853.  
  854. (* --------------------------------------------------------------------- *)
  855.  
  856. PROCEDURE OpenScreenTagList (newScreen: ID.NewScreenPtr;
  857.                              tagList  : UD.TagItemPtr
  858.                             ): ID.ScreenPtr;
  859.  
  860.    CONST KeinScreen = "Error in OpenClose.OpenScreenTagList!";
  861.  
  862.    VAR ScreenPtr: ID.ScreenPtr;
  863.  
  864.    (* ------------------------------------------------------------------ *)
  865.  
  866.    BEGIN (* Funktion OpenScreen *)
  867.  
  868.    ScreenPtr := NIL;
  869.    
  870.    IF Kick20 THEN
  871.       Forbid ();
  872.       ScreenPtr := IL.OpenScreenTagList (newScreen, tagList);
  873.       Permit ();
  874.    END (* IF Kick20 *);
  875.  
  876.    IF ScreenPtr # NIL THEN
  877.  
  878.       (*$ NilChk := FALSE *)
  879.  
  880.       IF NOT NeuesListenElement (screen, ScreenPtr) THEN
  881.          Forbid ();
  882.          IL.CloseScreen (ScreenPtr);
  883.          ScreenPtr := NIL;
  884.          Permit ();
  885.  
  886.          HandleError (KeinScreen);
  887.       END (* IF NOT *);
  888.  
  889.       (*$ POP NilChk *)
  890.  
  891.    ELSE (* kein Screen geöffnet *)
  892.       HandleError (KeinScreen);
  893.    END (* IF ScreenPtr *);
  894.  
  895.    RETURN ScreenPtr;
  896. END OpenScreenTagList (* Funktion *);
  897.  
  898. (* --------------------------------------------------------------------- *)
  899.  
  900. PROCEDURE OpenWindow (VAR newWindow: ID.NewWindow): ID.WindowPtr;
  901.  
  902.    CONST KeinFenster = "Error in OpenClose.OpenWindow!";
  903.  
  904.    VAR IBasePtr : ID.IntuitionBasePtr;
  905.        ScreenPtr: ID.ScreenPtr;
  906.        WindowPtr: ID.WindowPtr;
  907.  
  908.    (* ------------------------------------------------------------------ *)
  909.  
  910.    BEGIN (* Funktion OpenWindow *)
  911.  
  912.    ScreenPtr := NIL;
  913.    WindowPtr := NIL;
  914.  
  915.    Forbid ();
  916.  
  917.    IF newWindow.type = ID.customScreen THEN
  918.       IBasePtr := IL.OpenIntuition ();
  919.  
  920.       IF IBasePtr # NIL THEN
  921.          ScreenPtr := IBasePtr^.firstScreen;
  922.  
  923.          WHILE (ScreenPtr # NIL) AND (ScreenPtr # newWindow.screen) DO
  924.             ScreenPtr := ScreenPtr^.nextScreen;
  925.          END (* WHILE (ScreenPtr *);
  926.       END (* IF IBasePtr *);
  927.  
  928.       IF ScreenPtr # NIL THEN
  929.          WindowPtr := IL.OpenWindow (newWindow);
  930.       END (* IF ScreenPtr *);
  931.  
  932.    ELSE (* workbenchScreen *)
  933.       WindowPtr := IL.OpenWindow (newWindow);
  934.    END (* IF newWindow.type *);
  935.  
  936.    Permit ();
  937.  
  938.    IF WindowPtr # NIL THEN
  939.  
  940.       (*$ NilChk := FALSE *)
  941.  
  942.       IF NOT NeuesListenElement (window, WindowPtr) THEN
  943.          Forbid ();
  944.          IL.CloseWindow (WindowPtr);
  945.          WindowPtr := NIL;
  946.          Permit ();
  947.  
  948.          HandleError (KeinFenster);
  949.       END (* IF NOT *);
  950.  
  951.       (*$ POP NilChk *)
  952.  
  953.    ELSE (* Fehler beim Öffnen! *)
  954.       HandleError (KeinFenster);
  955.    END (* IF WindowPtr # NIL *);
  956.  
  957.    RETURN WindowPtr;
  958. END OpenWindow (* Funktion *);
  959.  
  960. (* --------------------------------------------------------------------- *)
  961. (* --------------------------------------------------------------------- *)
  962.  
  963. BEGIN (* IMPLEMENTATION MODULE OpenClose - initialisieren *)
  964.  
  965. AFPuffer := DefAFPuffer;
  966. AFPufferPtrMem := NIL;
  967. AFPufferPtrDisk := NIL;
  968. DebugMode := DefDebugMode;
  969. Kick20 := (kickVersion >= 37);
  970. RememberAFPuffer := DefRememberAFPuffer;
  971. ResListePtr := NIL;
  972. ErrorHandling := ErrorAssert;
  973.  
  974. (* --------------------------------------------------------------------- *)
  975.  
  976. CLOSE; (* IMPLEMENTATION MODULE OpenClose - am Schluß aufräumen *)
  977.  
  978. WHILE ResListePtr # NIL DO (* ganz schön vergesslich! *)
  979.     HilfePtr := CAST (ResourcenListePtr, ResListePtr^.Knoten.succ);
  980.  
  981.     LoescheResourceEintrag (ResListePtr);
  982.  
  983.     ResListePtr := HilfePtr;
  984. END (* WHILE ResListePtr *);
  985.  
  986. DeallocateAFMemPuffer;
  987. DeallocateAFDiskPuffer;
  988.  
  989. END OpenClose (* IMPLEMENTATION MODULE *).
  990.